home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / modify.t < prev    next >
Text File  |  1988-05-02  |  4KB  |  101 lines
  1. (herald modify (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;;; modify-location and friends
  27.  
  28. ;;; in
  29. ;;;     (modify-location form (lambda (fetch store) value))
  30. ;;; the continuation is called, being passed an access procedure fetch of no
  31. ;;; arguments which fetches the value in the location indicated by
  32. ;;; form, and an update procedure store of one argument, which will store a
  33. ;;; new value in that place.
  34.  
  35. (define-syntax (modify-location form cont)
  36.   (cond ((symbol? form)
  37.          (let ((new-value (generate-symbol 'value)))
  38.            `(,cont (,(t-syntax 'lambda) () ,form)
  39.                    (,(t-syntax 'lambda) (,new-value)
  40.                     (,(t-syntax 'set) ,form ,new-value)))))
  41.         ;; atom case should err.
  42.         ;; what about special form case?
  43.         (else
  44.          (let ((new-form (map (lambda (subform)
  45.                                  (ignore subform)
  46.                                  (generate-symbol 'subform))
  47.                               form)))
  48.            `(,(t-syntax 'let) ,(map list new-form form)
  49.               (,cont (,(t-syntax 'lambda) () ,new-form)
  50.                      (,(t-syntax 'lambda) (new-value)
  51.               (,(t-syntax 'set) ,new-form new-value))))))))
  52.  
  53. (define-syntax (modify form proc)
  54.   (let ((fetch (generate-symbol 'fetch))
  55.         (store (generate-symbol 'store)))
  56.     `(,(t-syntax 'modify-location)
  57.       ,form
  58.       (,(t-syntax 'lambda) (,fetch ,store)
  59.                (,store (,proc (,fetch)))))))
  60.  
  61. (define-syntax (swap form new-value)
  62.   (let ((fetch (generate-symbol 'fetch))
  63.         (store (generate-symbol 'store)))
  64.     `(,(t-syntax 'modify-location)
  65.       ,form
  66.       (,(t-syntax 'lambda) (,fetch ,store)
  67.                (,(t-syntax 'block0) (,fetch)
  68.                         (,store ,new-value))))))
  69.  
  70. (define-syntax (exchange form-1 form-2)
  71.   (let ((fetch-1 (generate-symbol 'fetch))
  72.         (store-1 (generate-symbol 'store))
  73.         (fetch-2 (generate-symbol 'fetch))
  74.         (store-2 (generate-symbol 'store)))
  75.     `(,(t-syntax 'modify-location) ,form-1
  76.        (,(t-syntax 'lambda) (,fetch-1 ,store-1)
  77.          (,(t-syntax 'modify-location) ,form-2
  78.            (,(t-syntax 'lambda) (,fetch-2 ,store-2)
  79.              (,store-1 (,(t-syntax 'block0) (,fetch-2)
  80.                                (,store-2 (,fetch-1))))))))))
  81.  
  82. (define-syntax (increment form)
  83.   `(,(t-syntax 'modify) ,form 1+))
  84.  
  85. (define-syntax (decrement form)
  86.   `(,(t-syntax 'modify) ,form -1+))
  87.  
  88. (define-syntax (push form thing)
  89.   (let ((fetch (generate-symbol 'fetch))
  90.         (store (generate-symbol 'store)))
  91.     `(,(t-syntax 'modify-location) ,form
  92.        (,(t-syntax 'lambda) (,fetch ,store)
  93.          (,store (cons ,thing (,fetch)))))))
  94.  
  95. (define-syntax (pop form)
  96.   `(,(t-syntax 'modify-location) ,form
  97.      (,(t-syntax 'lambda) (fetch store)
  98.        (,(t-syntax 'let) ((temp (fetch)))
  99.          (store (cdr temp))
  100.          (car temp)))))
  101.